###############################################################################
# Captcha.pl                                                                  #
###############################################################################
# YaBB: Yet another Bulletin Board                                            #
# Open-Source Community Software for Webmasters                               #
# Version:        YaBB 2.2                                                    #
# Packaged:       November 8, 2007                                            #
# Distributed by: http://www.yabbforum.com                                    #
# =========================================================================== #
# Copyright (c) 2000-2007 YaBB (www.yabbforum.com) - All Rights Reserved.     #
# Software by:  The YaBB Development Team                                     #
#               with assistance from the YaBB community.                      #
# Sponsored by: Xnull Internet Media, Inc. - http://www.ximinc.com            #
#               Your source for web hosting, web design, and domains.         #
###############################################################################

$captchaplver = 'YaBB 2.2 $Revision: 1.7 $';
if ($action eq 'detailedversion') { return 1; }

$| = 1;

# Generate GIF image of a message
# Version 1.5
# by Andrew Gregory
# 17 February 2007
#
# http://www.scss.com.au/family/andrew/webdesign/msgimg/
#
# This work is licensed under the Creative Commons
# Attribution-NonCommercial-ShareAlike License. To view a copy of this license,
# visit http://creativecommons.org/licenses/by-nc-sa/1.0/ or send a letter to
# Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA.

if(!$rgb_foreground){
	$rgb_foreground = "0000EE";
}

if(!$rgb_shade){
	$rgb_shade = "999999";
}

if(!$rgb_background){
	$rgb_background = "FFFFFF";
}

sub captcha {
	my $msg = $_[0];
	## make colors for validation image into hex again ##
	$rgb_foreground =~ s/\#//g;
	$rgb_shade =~ s/\#//g;
	$rgb_background =~ s/\#//g;
	$r_f = substr($rgb_foreground,0,2);
	$g_f = substr($rgb_foreground,2,2);
	$b_f = substr($rgb_foreground,4,2);
	$r_s = substr($rgb_shade,0,2);
	$g_s = substr($rgb_shade,2,2);
	$b_s = substr($rgb_shade,4,2);
	$r_b = substr($rgb_background,0,2);
	$g_b = substr($rgb_background,2,2);
	$b_b = substr($rgb_background,4,2);

	# color for center cross of the dots (RGB)
	$highcolor = pack("H2",$r_f);
	$highcolor .= pack("H2",$g_f);
	$highcolor .= pack("H2",$b_f);

	# color for shade in the dots (RGB)
	$shadecolor = pack("H2",$r_s);
	$shadecolor .= pack("H2",$g_s);
	$shadecolor .= pack("H2",$b_s);


	# color for background of the dots (RGB)
	$backcolor = pack("H2",$r_b);
	$backcolor .= pack("H2",$g_b);
	$backcolor .= pack("H2",$b_b);

	if (!$translayer || $translayer == "0") { $TRANSPARENT_INDEX = "\3"; }
	else { $TRANSPARENT_INDEX = "\0"; }

	# Palette

	$BITS_PER_PIXEL = 7;    # DON'T CHANGE THIS!!!

	# A note about BITS_PER_PIXEL: GIF data is bit packed. For example, if the code
	# size is 6 bits, then 4 codes can be packed into 3 bytes. This script does not
	# implement bit packing. 7 bits per pixel translates into 8 bits per code which
	# exactly matches a byte and therefore bit packing is not needed.

	$palette .= "$backcolor";     # 0 = white
	$palette .= "$shadecolor";    # 1 = grey
	$palette .= "$highcolor";     # 2 = almost black


	# Dot definition
	# Defines a dot in terms of palette colours.

	$DOT_WIDTH  = 3;
	$DOT_HEIGHT = 3;

	$dot = qq~
\1\2\1
\2\2\2
\1\2\1
~;
	$nodot = qq~
\0\0\0
\0\0\0
\0\0\0
~;

	$invdot = qq~
\1\0\1
\0\0\0
\1\0\1
~;
	$invnodot = qq~
\1\1\1
\1\1\1
\1\1\1
~;


###############################################

###############################################
# Character definitions
	my($CHAR_WIDTH, $CHAR_HEIGHT, %ci);

	$CHAR_WIDTH  = 6;
	$CHAR_HEIGHT = 9;

$ci{' '} = qq~
......
......
......
......
......
......
......
......
......
~;
$ci{'!'} = qq~
..X...
..X...
..X...
..X...
..X...
......
..X...
......
......
~;
$ci{'"'} = qq~
.X.X..
.X.X..
.X.X..
......
......
......
......
......
......
~;
$ci{'#'} = qq~
.X.X..
.X.X..
XXXXX.
.X.X..
XXXXX.
.X.X..
.X.X..
......
......
~;
$ci{'$'} = qq~
..X...
.XXXX.
X.X...
.XXX..
..X.X.
XXXX..
..X...
......
......
~;
$ci{'%'} = qq~
XX....
XX..X.
...X..
..X...
.X....
X..XX.
...XX.
......
......
~;
$ci{'&'} = qq~
.X....
X.X...
X.X...
.X....
X.X.X.
X..X..
.XX.X.
......
......
~;
$ci{'\''} = qq~
..X...
..X...
..X...
......
......
......
......
......
......
~;
$ci{'('} = qq~
...X..
..X...
.X....
.X....
.X....
..X...
...X..
......
......
~;
$ci{')'} = qq~
.X....
..X...
...X..
...X..
...X..
..X...
.X....
......
......
~;
$ci{'*'} = qq~
..X...
X.X.X.
.XXX..
..X...
.XXX..
X.X.X.
..X...
......
......
~;
$ci{'+'} = qq~
......
..X...
..X...
XXXXX.
..X...
..X...
......
......
......
~;
$ci{','} = qq~
......
......
......
......
......
..X...
..X...
.X....
......
~;
$ci{'-'} = qq~
......
......
......
XXXXX.
......
......
......
......
......
~;
$ci{'.'} = qq~
......
......
......
......
......
......
..X...
......
......
~;
$ci{'/'} = qq~
......
....X.
...X..
..X...
.X....
X.....
......
......
......
~;
$ci{':'} = qq~
......
......
......
..X...
......
..X...
......
......
......
~;
$ci{';'} = qq~
......
......
......
..X...
......
..X...
..X...
.X....
......
~;
$ci{'<'} = qq~
...X..
..X...
.X....
X.....
.X....
..X...
...X..
......
......
~;
$ci{'='} = qq~
......
......
XXXXX.
......
XXXXX.
......
......
......
......
~;
$ci{'>'} = qq~
.X....
..X...
...X..
....X.
...X..
..X...
.X....
......
......
~;
$ci{'?'} = qq~
.XXX..
X...X.
...X..
..X...
..X...
......
..X...
......
......
~;
$ci{'@'} = qq~
.XXX..
X...X.
X.X.X.
X.XXX.
X.XX..
X.....
.XXXX.
......
......
~;
$ci{'['} = qq~
XXXXX.
XX....
XX....
XX....
XX....
XX....
XXXXX.
......
......
~;
$ci{'\\'} = qq~
......
X.....
.X....
..X...
...X..
....X.
......
......
......
~;
$ci{']'} = qq~
XXXXX.
...XX.
...XX.
...XX.
...XX.
...XX.
XXXXX.
......
......
~;
$ci{'^'} = qq~
......
......
..X...
.X.X..
X...X.
......
......
......
......
~;
$ci{'_'} = qq~
......
......
......
......
......
......
XXXXX.
......
......
~;
$ci{'`'} = qq~
..X...
..X...
...X..
......
......
......
......
......
......
~;
$ci{'{'} = qq~
...XX.
..X...
..X...
.X....
..X...
..X...
...XX.
......
......
~;
$ci{'|'} = qq~
..X...
..X...
..X...
......
..X...
..X...
..X...
......
......
~;
$ci{'}'} = qq~
.XX...
...X..
...X..
....X.
...X..
...X..
.XX...
......
......
~;
$ci{'~'} = qq~
.X....
X.X.X.
...X..
......
......
......
......
......
......
~;
$ci{'0'} = qq~
.XXX..
X...X.
X..XX.
X.X.X.
XX..X.
X...X.
.XXX..
......
......
~;
$ci{'1'} = qq~
..X...
.XX...
..X...
..X...
..X...
..X...
.XXX..
......
......
~;
$ci{'2'} = qq~
.XXX..
X...X.
....X.
..XX..
.X....
X.....
XXXXX.
......
......
~;
$ci{'3'} = qq~
XXXXX.
....X.
...X..
..XX..
....X.
X...X.
.XXX..
......
......
~;
$ci{'4'} = qq~
...X..
..XX..
.X.X..
X..X..
XXXXX.
...X..
...X..
......
......
~;
$ci{'5'} = qq~
XXXXX.
X.....
XXXX..
....X.
....X.
X...X.
.XXX..
......
......
~;
$ci{'6'} = qq~
..XXX.
.X....
X.....
XXXX..
X...X.
X...X.
.XXX..
......
......
~;
$ci{'7'} = qq~
XXXXX.
....X.
...X..
..X...
.X....
.X....
.X....
......
......
~;
$ci{'8'} = qq~
.XXX..
X...X.
X...X.
.XXX..
X...X.
X...X.
.XXX..
......
......
~;
$ci{'9'} = qq~
.XXX..
X...X.
X...X.
.XXXX.
....X.
...X..
XXX...
......
......
~;
$ci{'A'} = qq~
..X...
.X.X..
X...X.
X...X.
XXXXX.
X...X.
X...X.
......
......
~;
$ci{'a'} = qq~
......
......
.XXX..
....X.
.XXXX.
X...X.
.XXXX.
......
......
~;
$ci{'B'} = qq~
XXXX..
X...X.
X...X.
XXXX..
X...X.
X...X.
XXXX..
......
......
~;
$ci{'b'} = qq~
X.....
X.....
XXXX..
X...X.
X...X.
X...X.
XXXX..
......
......
~;
$ci{'C'} = qq~
.XXX..
X...X.
X.....
X.....
X.....
X...X.
.XXX..
......
......
~;
$ci{'c'} = qq~
......
......
.XXXX.
X.....
X.....
X.....
.XXXX.
......
......
~;
$ci{'D'} = qq~
XXXX..
X...X.
X...X.
X...X.
X...X.
X...X.
XXXX..
......
......
~;
$ci{'d'} = qq~
....X.
....X.
.XXXX.
X...X.
X...X.
X...X.
.XXXX.
......
......
~;
$ci{'E'} = qq~
XXXXX.
X.....
X.....
XXXX..
X.....
X.....
XXXXX.
......
......
~;
$ci{'e'} = qq~
......
......
.XXX..
X...X.
XXXXX.
X.....
.XXXX.
......
......
~;
$ci{'F'} = qq~
XXXXX.
X.....
X.....
XXXX..
X.....
X.....
X.....
......
......
~;
$ci{'f'} = qq~
..XX..
.X..X.
.X....
XXXX..
.X....
.X....
.X....
......
......
~;
$ci{'G'} = qq~
.XXXX.
X.....
X.....
X.....
X..XX.
X...X.
.XXXX.
......
......
~;
$ci{'g'} = qq~
......
......
.XXX..
X...X.
X...X.
.XXXX.
....X.
.XXX..
......
~;
$ci{'H'} = qq~
X...X.
X...X.
X...X.
XXXXX.
X...X.
X...X.
X...X.
......
......
~;
$ci{'h'} = qq~
X.....
X.....
XXXX..
X...X.
X...X.
X...X.
X...X.
......
......
~;
$ci{'I'} = qq~
.XXX..
..X...
..X...
..X...
..X...
..X...
.XXX..
......
......
~;
$ci{'i'} = qq~
..X...
......
.XX...
..X...
..X...
..X...
.XXX..
......
......
~;
$ci{'J'} = qq~
....X.
....X.
....X.
....X.
....X.
X...X.
.XXX..
......
......
~;
$ci{'j'} = qq~
...X..
......
..XX..
...X..
...X..
...X..
X..X..
.XX...
......
~;
$ci{'K'} = qq~
X...X.
X..X..
X.X...
XX....
X.X...
X..X..
X...X.
......
......
~;
$ci{'k'} = qq~
X.....
X.....
X...X.
X..X..
XXX...
X..X..
X...X.
......
......
~;
$ci{'L'} = qq~
X.....
X.....
X.....
X.....
X.....
X.....
XXXXX.
......
......
~;
$ci{'l'} = qq~
.XX...
..X...
..X...
..X...
..X...
..X...
.XXX..
......
......
~;
$ci{'M'} = qq~
X...X.
XX.XX.
X.X.X.
X.X.X.
X...X.
X...X.
X...X.
......
......
~;
$ci{'m'} = qq~
......
......
XX.XX.
X.X.X.
X.X.X.
X.X.X.
X...X.
......
......
~;
$ci{'N'} = qq~
X...X.
X...X.
XX..X.
X.X.X.
X..XX.
X...X.
X...X.
......
......
~;
$ci{'n'} = qq~
......
......
XXXX..
X...X.
X...X.
X...X.
X...X.
......
......
~;
$ci{'O'} = qq~
.XXX..
X...X.
X...X.
X...X.
X...X.
X...X.
.XXX..
......
......
~;
$ci{'o'} = qq~
......
......
.XXX..
X...X.
X...X.
X...X.
.XXX..
......
......
~;
$ci{'P'} = qq~
XXXX..
X...X.
X...X.
XXXX..
X.....
X.....
X.....
......
......
~;
$ci{'p'} = qq~
......
......
XXXX..
X...X.
X...X.
XXXX..
X.....
X.....
......
~;
$ci{'Q'} = qq~
.XXX..
X...X.
X...X.
X...X.
X.X.X.
X..X..
.XX.X.
......
......
~;
$ci{'q'} = qq~
......
......
.XXXX.
X...X.
X...X.
.XXXX.
....X.
....X.
......
~;
$ci{'R'} = qq~
XXXX..
X...X.
X...X.
XXXX..
X.X...
X..X..
X...X.
......
......
~;
$ci{'r'} = qq~
......
......
X.XXX.
XX....
X.....
X.....
X.....
......
......
~;
$ci{'S'} = qq~
.XXX..
X...X.
X.....
.XXX..
....X.
X...X.
.XXX..
......
......
~;
$ci{'s'} = qq~
......
......
.XXXX.
X.....
.XXX..
....X.
XXXX..
......
......
~;
$ci{'T'} = qq~
XXXXX.
..X...
..X...
..X...
..X...
..X...
..X...
......
......
~;
$ci{'t'} = qq~
.X....
XXXX..
.X....
.X....
.X....
.X..X.
..XX..
......
......
~;
$ci{'U'} = qq~
X...X.
X...X.
X...X.
X...X.
X...X.
X...X.
.XXX..
......
......
~;
$ci{'u'} = qq~
......
......
X...X.
X...X.
X...X.
X..XX.
.XX.X.
......
......
~;
$ci{'V'} = qq~
X...X.
X...X.
X...X.
X...X.
X...X.
.X.X..
..X...
......
......
~;
$ci{'v'} = qq~
......
......
X...X.
X...X.
X...X.
.X.X..
..X...
......
......
~;
$ci{'W'} = qq~
X...X.
X...X.
X...X.
X.X.X.
X.X.X.
XX.XX.
.X.X..
......
......
~;
$ci{'w'} = qq~
......
......
X...X.
X...X.
X.X.X.
X.X.X.
.X.X..
......
......
~;
$ci{'X'} = qq~
X...X.
X...X.
.X.X..
..X...
.X.X..
X...X.
X...X.
......
......
~;
$ci{'x'} = qq~
......
......
X...X.
.X.X..
..X...
.X.X..
X...X.
......
......
~;
$ci{'Y'} = qq~
X...X.
X...X.
.X.X..
..X...
..X...
..X...
..X...
......
......
~;
$ci{'y'} = qq~
......
......
X...X.
X...X.
X...X.
.XXXX.
....X.
.XXX..
......
~;
$ci{'Z'} = qq~
XXXXX.
....X.
...X..
..X...
.X....
X.....
XXXXX.
......
......
~;
$ci{'z'} = qq~
......
......
XXXXX.
...X..
..X...
.X....
XXXXX.
......
......
~;
#
###############################################

my($nl, @lines, $len, $w, $h, $LINE_HEIGHT, $BLOCK_LIMIT);

# to measure length of the 'newline' character (cross platform LF vs CR+LF ???)
$nl = length qq~
~;
	
	$LINE_HEIGHT = $CHAR_HEIGHT * $DOT_HEIGHT;
	@lines = split("\n", $msg);
	$len = 0;
	foreach (@lines) { $len = length $_ if (length $_ > $len); }
	$w = $len * $CHAR_WIDTH * $DOT_WIDTH;
	$h = @lines * $LINE_HEIGHT;
	# LZW block limit - cannot allow the LZW code size to change from the initial
	# code size (we can't know when the code size will change because we aren't
	# implementing compression). The 3 is a fudge factor.
	$BLOCK_LIMIT = 2**$BITS_PER_PIXEL - 3;

	# Implementation notes:
	# * Image is NOT compressed! - Does not use LZW compression!
	# * For ease of output things are arranged so that the expected LZW code size is
	#   always 8 bits. The initial LZW code size is determined by the number of bits
	#   required to represent all possible colour indices, plus two additional codes
	#   used to (1) reset the LZW decode table and (2) mark the end of LZW data. By
	#   selecting a 128 entry colour table, the total of 130 initial LZW codes
	#   require 8 bits. During output, the decoding table is reset at regular
	#   intervals to prevent it from adding so many entries that the decoder would
	#   increase the expected code size to 9 bits.

	# GIF Signature
	print 'Content-type: image/gif', "\x0A\x0A";

	# Screen Descriptor
	print $TRANSPARENT_INDEX ? 'GIF89a' : 'GIF87a';

	# width, height
	print pack 'v2', $w, $h;

	# global colour map, 8 bits colour resolution, 7 bits per pixel
	print pack 'C1', 0xF0 + $BITS_PER_PIXEL - 1;

	# background colour = 0
	print "\0";

	# reserved
	print "\0";

	# Global Colour Map
	print $palette;
	print "\0" x ((2**$BITS_PER_PIXEL * 3) - length $palette);

	if ($TRANSPARENT_INDEX) {
		# Graphic Control Extension
		# extension introducer
		print "\x21";
		# graphic control label
		print "\xF9";
		# block size
		print "\x04";
		# no disposal method, no user input, transparent colour present
		print "\x01";
		# delay time
		print "\0\0";
		# transparent colour index
		print $TRANSPARENT_INDEX;
		# block terminator
		print "\0";
	}
	
	# Image Descriptor
	
	# image separator
	print ',';
	# left, top
	print "\0\0\0\0";
	# width, height
	print pack 'v2', $w, $h;
	# use global colour map (not local), sequential (not interlaced) 
	print "\0";
	
	# Raster Data
	
	# code size
	print pack 'C', $BITS_PER_PIXEL;
	
	# the data is output in blocks with a leading byte count
	my($img, $line, $random_number);
	my($y, $cy, $dy);
	my($x, $cx, $i, $c, $d, $di, $r);
	$range = 10;
	for ($y = 0; $y < $h; $y++) {
		$cy = int($y / $DOT_HEIGHT) % $CHAR_HEIGHT; # y coord in character dots
		$dy = $y % $DOT_HEIGHT;
		for ($x = 0; $x < $w; $x += $DOT_WIDTH) {
		$random_number = int(rand($range));
			$cx = int($x / $DOT_WIDTH) % $CHAR_WIDTH; # x coord in character dots
			$i = int($x / $DOT_WIDTH / $CHAR_WIDTH); # index into message string
			$line = $lines[$y / $LINE_HEIGHT];
			$c = ($i < length $line) ? substr $line, $i, 1 : ' '; 
			$d = substr $ci{$c}, $cy * ($CHAR_WIDTH + $nl) + $cx + $nl, 1; # dot in character definition
			if ($distortion > 0){
				$dis_level = 9 - $distortion;
				if($random_number <= $dis_level){ $di = ($d eq 'X') ? $dot : $nodot;} elsif ($random_number > $dis_level){ $di = ($d eq 'X') ? $dot : $invnodot;}
			} else { 
				$di = ($d eq 'X') ? $dot : $nodot;
			}
			$di = substr $di, $dy * ($DOT_WIDTH + $nl) + $nl, $DOT_WIDTH;
			for ($i = 0; $i < length $di; $i++) {
				$c = ord substr $di, $i, 1;
				if ($randomizer > 0){
					# Start of randomizer - comment this block out if you don't like it!
					if($randomizer == 1){$rc1 = 1; $rc2 = 1;}
					if($randomizer == 2){$rc1 = 2; $rc2 = 2;}
					if($randomizer == 3){$rc1 = 1; $rc2 = 2;}
					$r = rand;
					if ($r < .1) {
						$c += $rc1;
					} elsif ($r > .9) {
						$c += $rc2;
					}
					# End of randomizer
				}
				$c = chr $c;
				$img .= $c;
			}
		}
	}
	# Re-arrange the image data so it's bit-packed
	my($cnt, $pkdimg, $buf, $bufbits);
	$i = 0;
	$buf = 0;
	$bufbits = 0;
	while ($i <= length $img) {
		if ($i < length $img) {
			# Output each pixel
			$c = ord substr $img, $i, 1;
			$c &= 2**$BITS_PER_PIXEL-1;
			$buf |= $c << $bufbits;
			$bufbits += $BITS_PER_PIXEL + 1;
			$i++;
			# Insert LZW table clear code before the decoder will grow the bit size
			# The minus 2 is a fudge factor
			if ($i % (2**$BITS_PER_PIXEL-2) == 0) {
				$c = 2**$BITS_PER_PIXEL;
				$buf |= $c << $bufbits;
				$bufbits += $BITS_PER_PIXEL + 1;
			}
		} else {
			#Output LZW end code
			$c = 2**$BITS_PER_PIXEL+1;
			$buf |= $c << $bufbits;
			$bufbits += $BITS_PER_PIXEL + 1;
			$i++;
		}
		while ($bufbits >= 8) {
			$c = chr ($buf & 255);
			$pkdimg .= $c;
			$buf >>= 8;
			$bufbits -= 8;
		}
	}
	$pkdimg .= chr $buf;
	# Output image data
	$i = 0;
	while ($i < length $pkdimg) {
		$cnt = (length $pkdimg) - $i;
		$cnt = 255 if ($cnt > 255);
		print pack 'C', $cnt;
		print substr $pkdimg, $i, $cnt;
		$i += $cnt;
	}
	# Finish up
	print "\0"; # zero byte count (end of raster data)

	# GIF Terminator
	print ';';
}

1;
